home *** CD-ROM | disk | FTP | other *** search
/ MacHack 1996 / MacHack 1996.toast / Presentations / Presentations ’94 / Timothy Knox / Pocket6.3 / Examples / Graphics < prev    next >
Text File  |  1994-06-24  |  6KB  |  147 lines
  1. ( Grafics words for Pocket Forth 0.6 )
  2. forget task : task ; decimal
  3. 0 28 +md !  page
  4.  
  5. ( create named rects )
  6. : RECT ( compile: -- ) ( run: -- addr ) variable 6 allot ;
  7.  
  8. ( rect words work on any 8 bytes )
  9. : !RECT ( t l b r rect -- ) >r  swap r 4 + 2!  swap r> 2! ;
  10. : @RECT ( rect -- t l b r ) dup 2@ swap  rot 4 + 2@ swap ;
  11. : @TL ( rect -- t l ) @rect 2drop ;
  12. : RCENTER ( rect -- h v ) @rect >r swap >r  ( -- tb r: -- rl )
  13.     over - 2 / +  2r>  dup rot swap - 2 / + swap ;
  14. : RCLIP ( rect -- ) a>r ,$ A87B ; ( _ClipRect )
  15. : RINVALID ( rect -- ) a>r ,$ A928 ;  ( _InvalRect )
  16. : ROFFSET ( h v rect -- ) a>r 2>r ,$ A8A8 ;  ( _OffsetRect )
  17. : RINSET ( h v rect -- ) a>r 2>r ,$ A8A9 ;  ( _InsetRect )
  18. : ?IN ( h v rect -- flag ) ( true if h,v is in rect at addr )
  19.     0 >r  rot rot 2>r  a>r  ,$ A8AD r> ;  ( _PtInRect )
  20. : ?EMPTY ( rect -- flag ) 0 >r a>r ,$ A8AE r> ;  ( _EmptyRect )
  21.  
  22. ( rect drawing )
  23. : RFRAME ( rect -- ) a>r ,$ A8A1 ;  ( _FrameRect )
  24. : OFRAME ( rect -- ) a>r ,$ A8B7 ;  ( _FrameOval )
  25. : RERASE ( rect -- ) a>r ,$ A8A3 ;  ( _EraseRect )
  26. : OERASE ( rect -- ) a>r ,$ A8B9 ;  ( _EraseOval )
  27. : RINVERT ( rect -- ) a>r ,$ A8A4 ;  ( _InvertRect )
  28. : OINVERT ( rect -- ) a>r ,$ A8BA ;  ( _InvertOval )
  29. : RPAINT ( rect -- ) a>r ,$ A8A2 ;  ( _PaintRect )
  30. : OPAINT ( rect -- ) a>r ,$ A8B8 ;  ( _PaintOval )
  31.  
  32. ( Read PICT resources from a file on disk ) ( If the pictures ... )
  33. (  ... are in the current file, only getpict need be called. )
  34. variable #REF  ( resource file reference number )
  35. : ROPEN ( addr -- ) ( rel addr of the file/path name )
  36.     0 >r  a>r ,$ A997 r> #ref ! ;  ( _OpenResFile )
  37. : RCLOSE ( -- ) ( always close after each opening )
  38.     #ref @ >r ,$ A99A  0 #ref ! ;  ( _CloseResFile )
  39. : GETPICT ( id -- dhandle ) 0 0 2>r  >r  ,$ A9BC  2r> ;  ( _GetPict )
  40.  
  41. ( create pictures )
  42. : PICTURE ( rect -- dhandle ) ( start a picture definition )
  43.     0 0 2>r  a>r  ,$ A8F3 2r> ;  ( _OpenPicture )
  44. : PCLOSE ,$ A8F4 ; macro  ( _ClosePicture )
  45. : PKILL ( addr -- ) 2@ 2>r ,$ A8F5 ; ( _KillPicture at addr )
  46.  
  47. ( display pictures )
  48. : PRECT ( dhandle -- t l b r ) ( the Picture RECT )
  49.     dl@ 2dup  2 0 d+ dl@  2swap  6 0 d+ dl@ ;
  50. : PSIZE ( dhandle -- h v ) prect rot - abs  rot rot - abs ;
  51. : DPICT ( dhandle h v -- ) ( draw a picture in its own rect )
  52.     2over psize 2over d+  here !rect
  53.     2>r  here a>r ,$ A8F6 ;  ( _DrawPicture )
  54. : PDRAW ( rect dhandle -- ) ( draw a picture in a rect )
  55.     2>r a>r ,$ A8F6 ;  ( _DrawPicture )
  56.  
  57. ( regions ) ( keep the handle on the stack "dhandle" )
  58. : REGION ( -- dhandle ) ( create an open region, deliver a handle )
  59.     0 0 2>r ,$ A8D8 2r>  ,$ A8DA ;  ( _NewRgn  _OpenRgn )
  60. : RGCLOSE ( dhandle -- ) 2>r ,$ A8DB ; macro  ( _CloseRgn )
  61. : RGDISP ( dhandle -- ) 2>r ,$ A8D9 ; macro  ( _DisposRgn )
  62. : RGCLIP ( dhandle -- ) 2>r ,$ A879 ; macro  ( _SetClip )
  63. : ?RGIN ( dhandle h v -- flag ) ( true if h,v is in region at dhandle )
  64.     0 >r 2>r 2>r ,$ A8E8 r> ;  ( _PtInRegion )
  65.  
  66. ( region drawing )
  67. : RGFRAME ( dhandle -- ) 2>r ,$ A8D2 ; macro  ( _FrameRgn )
  68. : RGERASE ( dhandle -- ) 2>r ,$ A8D4 ; macro  ( _EraseRgn )
  69. : RGINVERT ( dhandle -- ) 2>r ,$ A8D5 ; macro  ( _InvertRgn )
  70.  
  71. ( font words )
  72. : !FONT ( n -- ) >r ,$ A887 ; macro  ( _TextFont ) ( set font )
  73. : !FSIZE ( n -- ) >r ,$ A88A ; macro  ( _TextSize ) ( set size )
  74. : !FACE ( face -- ) >r ,$ A888 ; macro ( _TextFace ) ( set style )
  75. : !FMODE ( mode -- ) >r ,$ A889 ; macro ( _TextMode ) ( set mode )
  76. : SFONT ( -- ) 0 !font  12 !fsize ;  ( set System font )
  77. : NFONT ( -- ) 4 !font  09 !fsize  0 !fmode ;  ( set Normal font )
  78.  
  79. ( Polygons ) ( keep the handle in a 2variable "poly" )
  80. : NPOLY ( poly -- ) 0 0 2>r ,$ A8CB 2r> rot 2! ;  ( _OpenPoly )
  81. : CPOLY ( -- ) ,$ A8CC ; macro  ( _ClosePgon )
  82. : FPOLY ( poly -- ) 2@ 2>r ,$ A8C6 ;  ( _FramePoly )
  83. : EPOLY ( poly -- ) 2@ 2>r ,$ A8C8 ;  ( _ErasePoly )
  84. : KPOLY ( poly -- ) 2@ 2>r ,$ A8CD ;  ( _KillPoly )
  85. : ?PHIT ( h v poly -- flag ) ( true if h,v is in polyBBox )
  86.     0 >r  2@ dl@  2 0 d+  2swap 2>r  2>r ,$ A8AD r> ;  ( _PtInRect )
  87.  
  88. ( old style colors )
  89.  33 constant BLACK     30 constant WITE
  90. 205 constant RED      341 constant GREEN
  91. 409 constant BLUE     273 constant CYAN
  92. 137 constant MAGENTA   69 constant YELLOW
  93. : FCOLOR ( color.code -- ) 0 2>r ,$ A862 ;  ( _ForeColor )
  94. : BCOLOR ( back.color -- ) 0 2>r ,$ A863 ;  ( _BackColor )
  95.  
  96.  
  97. ( A demonstration )
  98. : DEMO ;  ( The infamous Mondrian program w/ enhancement )
  99.  
  100. \ Random numbers
  101. : SEED ( -- daddr ) ,$ 2d15 126 0 dnegate d+ ;
  102. : TIME ( -- d ) 524 0 dl@ ;
  103. : RANDOMIZE time seed dl! ;
  104. : RANDOM ( n -- n' )
  105.     0 >r ,$ A861  r> ( _Random )
  106.     swap 32768 */ abs ;  ( scale to size from stack )
  107.  
  108. : SSIZE ( -- h v )  ( screen size in pixels )
  109.     ,$ 2d2d ,$ ff8c ; macro  ( move.l screenBits[a5],-[ps] )
  110. : WSIZE ( h v -- ) ( change the window size )
  111.     2dup  8 +md 2!  ( set the scroll rect )
  112.     0 +md 2@ 2>r  2>r  256 >r  ,$ A91D ;  ( _SizeWindow )
  113.  
  114. create COLORS  ( use an array of old style colors )
  115.     yellow , cyan , wite , blue , yellow , wite ,
  116. : RCOLOR 6 random 2* colors + @ ;  ( pick a color at random )
  117.  
  118. rect INRECT  ( drawn in rect )
  119. rect MRECT ( the random rect )
  120.  
  121. : WIDTH  inrect dup 6 + @ 50 - random swap 2+ @ + ;
  122. : HEIGHT inrect dup 4 + @ 52 - random swap @ + ;
  123.  
  124. : DRAW ( draw a random rect in inrect )
  125.     height width height width  mrect !rect  ( set random rect )
  126.     rcolor fcolor  mrect
  127.     7 random IF rinvert ELSE opaint THEN
  128.     750 random 0= IF inrect rerase  THEN ;
  129.  
  130. : MONDRIAN ( -- )
  131.     0 +md 2@ 2>r  0 20 2>r  1 >r ,$ A91B  ( _MoveWindow to top left )
  132.     ssize wsize  ( set the window to full screen )
  133.     black bcolor  4 +md rerase
  134.     52 50  8 +md 2@  -53 -51  d+ swap  inrect !rect  ( drawing rect )
  135.     inrect rframe  1 1 inrect rinset  ( make a black frame )
  136.     wite bcolor  inrect rerase  ( erase pane )
  137.     8 +md @ 2/ 100 - 40 !pen  ( pen position for title )
  138.     3 !fmode  sfont  ." Press a key to end the demo."
  139.     randomize
  140.     BEGIN draw ?terminal ?button or UNTIL  ( wait )
  141.     black fcolor  384 178 wsize  nfont
  142.     0 +md 2@ 2>r  2 40 2>r  1 >r ,$ A91B  ( _MoveWindow to normal )
  143.     page ." Graphics words are loaded." cr ;
  144.  
  145. mondrian
  146. forget demo  -1 28 +md !
  147.